home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / thomas / thomas.lha / Thomas / Thomas-1.1 / src / runtime-collections-iterate.sc < prev    next >
Text File  |  1992-09-06  |  20KB  |  572 lines
  1. ;*              Copyright 1992 Digital Equipment Corporation
  2. ;*                         All Rights Reserved
  3. ;*
  4. ;* Permission to use, copy, and modify this software and its documentation is
  5. ;* hereby granted only under the following terms and conditions.  Both the
  6. ;* above copyright notice and this permission notice must appear in all copies
  7. ;* of the software, derivative works or modified versions, and any portions
  8. ;* thereof, and both notices must appear in supporting documentation.
  9. ;*
  10. ;* Users of this software agree to the terms and conditions set forth herein,
  11. ;* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
  12. ;* right and license under any changes, enhancements or extensions made to the
  13. ;* core functions of the software, including but not limited to those affording
  14. ;* compatibility with other hardware or software environments, but excluding
  15. ;* applications which incorporate this software.  Users further agree to use
  16. ;* their best efforts to return to Digital any such changes, enhancements or
  17. ;* extensions that they make and inform Digital of noteworthy uses of this
  18. ;* software.  Correspondence should be provided to Digital at:
  19. ;* 
  20. ;*            Director, Cambridge Research Lab
  21. ;*            Digital Equipment Corp
  22. ;*            One Kendall Square, Bldg 700
  23. ;*            Cambridge MA 02139
  24. ;* 
  25. ;* This software may be distributed (but not offered for sale or transferred
  26. ;* for compensation) to third parties, provided such third parties agree to
  27. ;* abide by the terms and conditions of this notice.
  28. ;* 
  29. ;* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
  30. ;* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
  31. ;* MERCHANTABILITY AND FITNESS.   IN NO EVENT SHALL DIGITAL EQUIPMENT
  32. ;* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
  33. ;* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
  34. ;* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
  35. ;* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
  36. ;* SOFTWARE.
  37.  
  38. ; $Id: runtime-collections-iterate.scm,v 1.20 1992/09/07 04:16:53 jmiller Exp $
  39.  
  40. ;;;;; Handles the iteration protocol of collections, including the method
  41. ;;;;; specializations for all collection types.
  42.  
  43. ;;;;
  44. ;;;; THE ITERATION PROTOCOL (page 122)
  45. ;;;; The specializations occur immediately after the definition of the
  46. ;;;; generic function.
  47.  
  48.  
  49.   ;; Implementation of iteration state:
  50.   ;;
  51.   ;; <EMPTY-LIST>: no states available
  52.   ;; <PAIR> and <LIST>: the object itself, with #F terminating
  53.   ;; <ARRAY>: array of index values, incrementing "odometer style"
  54.   ;; <TABLE>: pair of index into hash table and pointer to current
  55.   ;;          entry in bucket.  Pointer is actually the list whose car is the
  56.   ;;          key/element pair.   [state == (list hash-index bucket-left)]
  57.   ;; <BYTE-STRING>: inherits from <array>
  58.   ;; <STRING>: not handled, any user-specified subclass must supply
  59.   ;;           operations
  60.   ;; <DEQUE>: pointer to current entry
  61.   ;; <RANGE>: current value
  62.  
  63. (define dylan:next-state "define dylan:next-state")
  64. (define dylan:initial-state "define dylan:initial-state")
  65. (define dylan:current-element "define dylan:current-element")
  66. (define dylan:copy-state "define dylan:copy-state")
  67. (define dylan:final-state "define dylan:final-state")
  68. (define dylan:previous-state "define dylan:previous-state")
  69.  
  70. (let ()
  71.   ;;
  72.   ;; INITIAL-STATE
  73.   ;;
  74.   (set! dylan:initial-state
  75.     (dylan::generic-fn 'initial-state
  76.       one-collection
  77.       (lambda (collection)
  78.     (dylan-call
  79.      dylan:error
  80.      "initial-state -- not specialized for this type of collection"
  81.      collection))))
  82.   (add-method dylan:initial-state
  83.     (one-arg 'NULL <empty-list> (lambda (null) null #F)))
  84.   (add-method dylan:initial-state
  85.     (one-arg 'LIST <list> (lambda (list) list)))
  86.   (add-method dylan:initial-state
  87.     (one-arg 'ARRAY <array>
  88.       (lambda (array)
  89.     (let ((dimensions (dylan-call dylan:dimensions array)))
  90.       (if (all? positive? (iterate->list (lambda (x) x) dimensions))
  91.           (make-vector (length dimensions) 0)
  92.           #F)))))
  93.   (add-method dylan:initial-state
  94.     (one-arg 'DEQUE <deque>
  95.       (lambda (deque)
  96.     (dylan-call dylan:get-deque-front deque))))
  97.   (add-method dylan:initial-state
  98.     (one-arg 'RANGE <range>
  99.       (lambda (range)
  100.     (let ((start (dylan-call dylan:get-range-start range))
  101.           (end (dylan-call dylan:get-range-end range))
  102.           (step (dylan-call dylan:get-range-step range)))
  103.       (if end
  104.           (if ((if (negative? step) >= <=) start end)
  105.           start
  106.           #F)
  107.           start)))))
  108.   (add-method dylan:initial-state
  109.     (one-arg 'TABLE <table>
  110.       (lambda (table)
  111.     (let* ((hash-table (dylan-call dylan:get-hash-table table))
  112.            (next-bucket (find-next-non-empty-bucket hash-table -1)))
  113.       (if next-bucket
  114.           (list next-bucket (vector-ref hash-table next-bucket))
  115.           #F)))))
  116.  
  117.   ;;
  118.   ;; FINAL-STATE
  119.   ;;
  120.   (set! dylan:final-state
  121.     (dylan::generic-fn 'final-state one-object #F))
  122.   (add-method dylan:final-state
  123.     (one-arg 'EMPTY-LIST <empty-list>
  124.       (lambda (emp-list)
  125.     emp-list
  126.     #F)))
  127. ;  (add-method dylan:final-state        ; Not specified in the manual
  128. ;    (one-arg 'STRING <byte-string>             ; Only for efficiency
  129. ;      (lambda (string)
  130. ;    (let ((length (string-length string)))
  131. ;      (if (zero? length) #F (- length 1))))))
  132.   (add-method dylan:final-state        ; Not specified in the manual
  133.     (one-arg 'ARRAY <array>
  134.       (lambda (array)
  135.     (if (dylan-call dylan:empty? array)
  136.         #F
  137.         (map (lambda (index)
  138.            (- index 1))
  139.          (dylan-call dylan:dimensions array))))))
  140.   (add-method dylan:final-state
  141.     (one-arg 'SOV <simple-object-vector>
  142.       (lambda (vec)
  143.     (- (vector-length vec) 1))))
  144.   (add-method dylan:final-state
  145.     (one-arg 'DEQUE <deque>
  146.       (lambda (deque)
  147.     (dylan-call dylan:get-deque-last deque))))
  148.  
  149.   ;;
  150.   ;; NEXT-STATE
  151.   ;;
  152.   (set! dylan:next-state
  153.     (dylan::generic-fn 'next-state one-collection-and-a-state
  154.                #F))
  155.  
  156.   (add-method dylan:next-state
  157.     (dylan::function->method
  158.      (make-param-list `((LIST ,<list>) (STATE ,<object>)) #F #F #F)
  159.      (lambda (list state)
  160.        list                ; Ignored
  161.        (if (not (pair? state))
  162.        #F                ; If dotted list, and reached end
  163.        (let ((left (cdr state)))
  164.          (cond ((null? left) #F)
  165.                 ; For now: If not a pair, return the atom
  166.            ((not (pair? left)) left)
  167.            (else left)))))))
  168.  
  169.   (add-method dylan:next-state        ; Array => "Odometer style"
  170.     (dylan::function->method
  171.      (make-param-list `((ARRAY ,<array>) (STATE ,<simple-object-vector>))
  172.               #F #F #F)
  173.      (lambda (array state)
  174.        (let ((dimensions (dylan-call dylan:dimensions array)))
  175.      (let loop ((next-state-indices (list->vector
  176.                      (vector->list state)))
  177.             (dim-index (- (length dimensions) 1)))
  178.        (if (negative? dim-index)
  179.            #F
  180.            (cond ((= (+ (vector-ref next-state-indices dim-index) 1)
  181.              (list-ref dimensions dim-index))
  182.               (loop next-state-indices (- dim-index 1)))
  183.              ((> (+ (vector-ref next-state-indices dim-index) 1)
  184.              (list-ref dimensions dim-index))
  185.               (dylan-call dylan:error
  186.                   "next-state -- invalid state" state))
  187.              (else
  188.               (do ((i (+ dim-index 1) (+ i 1)))
  189.               ((>= i (vector-length next-state-indices)) 'done)
  190.             (vector-set! next-state-indices i 0))
  191.               (vector-set! next-state-indices dim-index
  192.                    (+ (vector-ref next-state-indices dim-index)
  193.                       1))
  194.               next-state-indices))))))))
  195.  
  196.   (add-method dylan:next-state
  197.     (dylan::function->method
  198.      (make-param-list `((NULL ,<empty-list>) (STATE ,<object>)) #F #F #F)
  199.      (lambda (emp-list state)
  200.        emp-list
  201.        state
  202.        #F)))
  203.  
  204.   (add-method dylan:next-state
  205.     (dylan::function->method
  206.      (make-param-list `((DEQUE ,<deque>) (STATE ,<object>)) #F #F #F)
  207.      (lambda (deque state)
  208.        deque                ; not used
  209.        (deque-entry.next state))))
  210.  
  211.   (add-method dylan:next-state
  212.     (dylan::function->method
  213.      (make-param-list `((RANGE ,<range>) (STATE ,<object>)) #F #F #F)
  214.      (lambda (range state)
  215.        (let* ((end (dylan-call dylan:get-range-end range))
  216.           (step (dylan-call dylan:get-range-step range))
  217.           (next (+ state step)))
  218.      (if end
  219.          (if ((if (negative? step) < >) next end)
  220.          #F
  221.          next)
  222.          next)))))            ; Unbounded range
  223.  
  224.   (add-method dylan:next-state
  225.     (dylan::function->method
  226.       (make-param-list `((TABLE ,<table>) (STATE ,<object>)) #F #F #F)
  227.       (lambda (table state)
  228.     (let ((hash-index (car state))
  229.           (bucket-left (cadr state))
  230.           (hash-table (dylan-call dylan:get-hash-table table)))
  231.     (cond ((null? bucket-left)
  232.            (dylan-call dylan:error
  233.                "(next-state <table> <object>) -- bad state"
  234.                table state))
  235.           ((null? (cdr bucket-left))
  236.            (let ((next-bucket (find-next-non-empty-bucket hash-table
  237.                                   hash-index)))
  238.          (if next-bucket
  239.              (list next-bucket (vector-ref hash-table next-bucket))
  240.              #F)))
  241.           (else (list hash-index (cdr bucket-left))))))))
  242.  
  243.   ;;
  244.   ;; PREVIOUS-STATE
  245.   ;;
  246.   (set! dylan:previous-state
  247.     (dylan::generic-fn 'previous-state one-collection-and-a-state #F))
  248.  
  249.   (add-method dylan:previous-state    ; Array => "Odometer style"
  250.     (dylan::function->method
  251.      (make-param-list `((ARRAY ,<array>) (STATE ,<sequence>)) #F #F #F)
  252.      (lambda (array state)
  253.        (let ((dimensions (dylan-call dylan:dimensions array)))
  254.      (let loop ((previous-state-indices state)
  255.             (dim-index (- (length dimensions) 1)))
  256.        (if (negative? dim-index)
  257.            #F
  258.            (if (< (vector-ref previous-state-indices dim-index) 1)
  259.            (loop previous-state-indices (- dim-index 1))
  260.            (begin
  261.              (vector-set! previous-state-indices dim-index
  262.                   (- (vector-ref previous-state-indices dim-index)
  263.                      1))
  264.              previous-state-indices))))))))
  265.   (add-method dylan:previous-state
  266.     (dylan::function->method
  267.      (make-param-list `((NULL ,<empty-list>) (STATE ,<object>)) #F #F #F)
  268.      (lambda (emp-list state) emp-list state #F)))
  269.  
  270. ;  (add-method dylan:previous-state    ; FOR EFFICIENCY ONLY!!
  271. ;    (dylan::function->method
  272. ;     (make-param-list `((SOV ,<simple-object-vector>) (STATE ,<sequence>)
  273. ;                              #F #F #F))
  274. ;     (lambda (vect state)
  275. ;       (cond ((not (pair? state))
  276. ;           (dylan-call dylan:error
  277. ;               "previous-state -- invalid state" vect state))
  278. ;         ((positive? (car state)) (list (- (car state) 1)))
  279. ;         ((zero? (car state)) #F)
  280. ;         (else (dylan-call dylan:error
  281. ;                   "previous-state -- invalid state"
  282. ;                   vect state))))))
  283.  
  284.   (add-method dylan:previous-state
  285.     (dylan::function->method
  286.      (make-param-list `((DEQUE ,<deque>) (STATE ,<object>)) #F #F #F)
  287.      (lambda (deque state)
  288.        deque                ; not used
  289.        (deque-entry.previous state))))
  290.   (add-method dylan:previous-state    ; Not defined in manual
  291.      (dylan::function->method
  292.       (make-param-list `((RANGE ,<range>) (STATE ,<object>)) #F #F #F)
  293.       (lambda (range state)
  294.     (let* ((start (dylan-call dylan:get-range-start range))
  295.            (step (dylan-call dylan:get-range-step range))
  296.            (prev (- state step)))
  297.      (if ((if (negative? step) > <) prev start)
  298.          #F
  299.          prev)))))
  300.  
  301.   ;;
  302.   ;; CURRENT-ELEMENT
  303.   ;;
  304.   (set! dylan:current-element
  305.     (dylan::generic-fn 'current-element one-collection-and-a-state
  306.        (lambda (collection state)
  307.      (dylan-call
  308.       dylan:error
  309.       "current-element -- not specialized for this collection type"
  310.       collection state))))
  311.  
  312.   (add-method dylan:current-element
  313.     (dylan::function->method
  314.      (make-param-list `((ARRAY ,<array>) (STATE ,<sequence>)) #F #F #F)
  315.      (lambda (array state)
  316.        (dylan-call dylan:element array state))))
  317.   (add-method dylan:current-element
  318.     (dylan::function->method
  319.      (make-param-list
  320.       `((SOV ,<simple-object-vector>) (STATE ,<sequence>)) #F #F #F)
  321.      (lambda (vec state)
  322.        (vector-ref vec (vector-ref state 0)))))
  323.   (add-method dylan:current-element
  324.     (dylan::function->method
  325.      (make-param-list `((LIST ,<list>) (STATE ,<object>)) #F #F #F)
  326.      (lambda (list state)
  327.        list                ; Ignored
  328.        (if (pair? state)
  329.        (car state)
  330.        state))))            ; If reached dotted list end...
  331.   (add-method dylan:current-element
  332.     (dylan::function->method
  333.      (make-param-list `((NULL ,<empty-list>) (STATE ,<sequence>)) #F #F #F)
  334.      (lambda (emp-list state) emp-list state #F)))
  335.   (add-method dylan:current-element
  336.     (dylan::function->method
  337.      (make-param-list
  338.       `((BYTE-STRING ,<byte-string>) (STATE ,<sequence>)) #F #F #F)
  339.      (lambda (string state)
  340.        (string-ref string (vector-ref state 0)))))
  341.   (add-method dylan:current-element
  342.     (dylan::function->method
  343.      (make-param-list `((DEQUE ,<deque>) (STATE ,<object>)) #F #F #F)
  344.      (lambda (deque state)
  345.        deque                ; not used
  346.        (deque-entry.value state))))
  347.   (add-method dylan:current-element
  348.     (dylan::function->method
  349.      (make-param-list `((RANGE ,<range>) (STATE ,<object>)) #F #F #F)
  350.      (lambda (range state)
  351.        range                ; not used
  352.        state)))
  353.   (add-method dylan:current-element
  354.     (dylan::function->method
  355.      (make-param-list `((TABLE ,<table>) (STATE ,<object>)) #F #F #F)
  356.      (lambda (table state)
  357.        table                ; Ignored
  358.        (cadr (car (cadr state))))))
  359.  
  360.   (set! dylan:copy-state
  361.     (dylan::generic-fn 'copy-state one-collection-and-a-state
  362.       (lambda (collection state)
  363.     collection            ; unused
  364.     state)))
  365.   )                    ; End of Iteration Functions
  366.  
  367.  
  368.  
  369.  
  370. ;; Iterate-Until: given a fn and a collection, iterate until
  371. ;; the collection runs out of elements or fn returns a non-#F value.
  372. (define (iterate-until fn collection)
  373.   (let loop ((state (dylan-call dylan:initial-state collection)))
  374.     (cond ((not state) #F)
  375.       ((fn (dylan-call dylan:current-element collection state)))
  376.       (else (loop
  377.          (dylan-call dylan:next-state collection state))))))
  378.  
  379. (define (iterate->list fn collection)
  380.   (let loop ((state (dylan-call dylan:initial-state collection))
  381.          (value '()))
  382.     (if state
  383.     (let ((new-value
  384.            (fn (dylan-call dylan:current-element collection state))))
  385.       (loop (dylan-call dylan:next-state collection state)
  386.         (cons new-value value)))
  387.     (reverse value))))
  388.  
  389. ;;;; The Iteration Protocol (page 122)
  390. ;;;; Actually, these are internal procedures used elsewhere to iterate
  391. ;;;; over collections or sets of collections
  392.  
  393. (define (collections-iterate fn done? default-value collections)
  394.   ;; FN is a Dylan function to be applied to parallel elements from
  395.   ;;    each collection.
  396.   ;; DONE? is a scheme function applied to the result of FN to test
  397.   ;;    for loop completion.  It returns #F to continue the iteration,
  398.   ;;    or a (Scheme) thunk to return the value.
  399.   ;; DEFAULT-VALUE is returned if any collection runs out before the
  400.   ;;    DONE? test causes an exit.
  401.   (if (not (all?
  402.         (lambda (collection)
  403.           (subclass? (get-type collection) <collection>))
  404.         collections))
  405.       (dylan-call dylan:error
  406.           "do -- not all arguments are collections" collections))
  407.   (let loop ((states
  408.           (map (lambda (collection)
  409.              (dylan-call dylan:initial-state collection))
  410.            collections)))
  411.     (if (any? (lambda (x) (not x)) states)
  412.     default-value
  413.     (let ((ins (map (lambda (collection state)
  414.               (dylan-call dylan:current-element collection state))
  415.             collections states)))
  416.       (let* ((next-val (dylan-apply fn ins))
  417.          (result? (done? next-val)))
  418.         (if result?
  419.         (result?)
  420.         (loop (map (lambda (collection state)
  421.                  (dylan-call dylan:next-state
  422.                      collection
  423.                      state))
  424.                collections states))))))))
  425.  
  426. (define (iterate! fn collection)
  427.   (let loop ((state (dylan-call dylan:initial-state collection)))
  428.     (if state
  429.     (begin
  430.       (fn (dylan-call dylan:current-element collection state))
  431.       (loop (dylan-call dylan:next-state collection state))))))
  432.  
  433. (define (find-next-non-empty-bucket hash-table index)
  434.   (let ((table-length (vector-length hash-table)))
  435.     (let loop ((i (+ index 1)))
  436.       (cond ((>= i table-length) #F)
  437.         ((null? (vector-ref hash-table i)) (loop (+ i 1)))
  438.         (else i)))))
  439.  
  440. ;;
  441. ;; DYLAN:GET-STATE: given a collection and a state index, return the
  442. ;;                  corresponding state.
  443. ;;                  initial-state = 0
  444. ;;                  If no corresponding state, return #F
  445. ;;
  446. (define dylan:get-state
  447.   (dylan::generic-fn 'get-state
  448.     (make-param-list `((COLLECTION ,<collection>) (INDEX ,<number>)) #F #F #F)
  449.     (lambda (collection index)
  450.       (do ((i 0 (+ i 1))
  451.        (state (dylan-call dylan:initial-state collection)
  452.           (dylan-call dylan:next-state collection state)))
  453.       ((or (= i index) (not state)) state)))))
  454.  
  455.  
  456. ;;;;
  457. ;;;; Collection Keys (page 123 )
  458. ;;;;
  459.  
  460. (define dylan:element
  461.   (dylan::generic-fn
  462.    'element
  463.    (make-param-list `((COLLECTION ,<collection>) (KEY ,<object>))
  464.             #F #F '(default:))
  465.    #F))
  466.  
  467. (add-method
  468.  dylan:element
  469.  (dylan::dylan-callable->method
  470.   (make-param-list `((COLLECTION ,<collection>) (KEY ,<object>))
  471.            #F #F '(default:))
  472.   (lambda (multiple-values next-method coll key . rest)
  473.     multiple-values
  474.     (dylan::keyword-validate next-method rest '(default:))
  475.     (dylan-call dylan:error
  476.         "element -- not specialized for this type" coll key rest))))
  477.  
  478. (add-method
  479.  dylan:element
  480.  (dylan::dylan-callable->method
  481.   (make-param-list `((EXPLICIT-KEY-COLLECTION ,<explicit-key-collection>)
  482.              (KEY ,<object>))
  483.            #F #F '(default:))
  484.   (lambda (multiple-values next-method exp-coll key . rest)
  485.     multiple-values
  486.     (dylan::keyword-validate next-method rest '(default:))
  487.     (let* ((default-marker (cons 1 2))
  488.        (default (dylan::find-keyword rest 'default (lambda ()
  489.                              default-marker))))
  490.       (do ((state (dylan-call dylan:initial-state exp-coll)
  491.           (dylan-call dylan:next-state exp-coll state)))
  492.       ((or (not state)
  493.            (dylan-call dylan:=
  494.                (dylan-call dylan:current-key exp-coll state)
  495.                key))
  496.        (cond (state (dylan-call dylan:current-element exp-coll state))
  497.          ((eq? default default-marker)
  498.           (dylan-call dylan:error
  499.                   "element -- no such element in collection"
  500.                   exp-coll key rest))
  501.          (else default))))))))
  502.  
  503. (add-method
  504.  dylan:element
  505.  (dylan::dylan-callable->method
  506.   (make-param-list `((SEQUENCE ,<sequence>) (KEY ,<integer>))
  507.            #F #F '(default:))
  508.   (lambda (multiple-values next-method seq key . rest)
  509.     multiple-values
  510.     (dylan::keyword-validate next-method rest '(default:))
  511.     (let* ((default-marker (cons 1 2))
  512.        (default (dylan::find-keyword rest 'default (lambda ()
  513.                              default-marker))))
  514.       (do ((state (dylan-call dylan:initial-state seq)
  515.           (dylan-call dylan:next-state seq state))
  516.        (k 0 (+ k 1)))
  517.       ((or (not state) (= k key))
  518.        (cond (state (dylan-call dylan:current-element seq state))
  519.          ((eq? default default-marker)
  520.           (dylan-call dylan:error
  521.                   "element -- no such element in collection"
  522.                   seq key rest))
  523.          (else default))))))))
  524.  
  525. (define dylan:key-sequence
  526.   (dylan::generic-fn 'key-sequence
  527.     one-collection
  528.     (lambda (collection)
  529.       (dylan-call dylan:error
  530.           "key-sequence -- not defined for this collection type"
  531.           collection))))
  532.  
  533. (add-method dylan:key-sequence
  534.   (dylan::function->method
  535.     (make-param-list
  536.      `((EXPLICIT-KEY-COLLECTION ,<explicit-key-collection>)) #F #F #F)
  537.     (lambda (exp-coll)
  538.       (do ((state (dylan-call dylan:initial-state exp-coll)
  539.           (dylan-call dylan:next-state exp-coll state))
  540.        (keys '() (cons (dylan-call dylan:current-key exp-coll state)
  541.                keys)))
  542.       ((not state) (reverse keys))))))
  543.  
  544. (add-method dylan:key-sequence
  545.   (dylan::function->method
  546.     one-sequence
  547.     (lambda (seq)
  548.       (let ((size (dylan-call dylan:size seq)))
  549.     (if (not size)
  550.         seq                ; Must be unbounded range
  551.         (dylan-call dylan:range
  552.             'from: 0
  553.             'through: (- size 1)
  554.             'by: 1))))))
  555.  
  556. (define dylan:current-key
  557.   (dylan::generic-fn 'current-key
  558.     (make-param-list
  559.      `((COLLECTION ,<explicit-key-collection>) (STATE ,<object>)) #F #F #F)
  560.     (lambda (collection state)
  561.       (dylan-call dylan:error
  562.           "current-key -- not implemented for this collection type"
  563.           collection state))))
  564.  
  565.  
  566. (add-method dylan:current-key
  567.   (dylan::function->method
  568.     (make-param-list `((TABLE ,<table>) (STATE ,<object>)) #F #F #F)
  569.     (lambda (table state)
  570.       table
  571.       (car (car (cadr state))))))
  572.